home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
elk-2_0.lha
/
elk-2.0
/
src
/
main.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-10-26
|
7KB
|
297 lines
#include "scheme.h"
#ifdef INCLUDE_UNISTD_H
# include <unistd.h>
#endif
#include TIME_H
#ifndef MAX_STACK_SIZE
# include <sys/resource.h>
#endif
#include <sys/types.h>
#include <sys/param.h>
#include <sys/stat.h>
#include <sys/file.h>
extern char *getenv();
char *stkbase;
int Max_Stack;
int Interpreter_Initialized;
int GC_Debug = 0;
int Case_Insensitive;
int Verbose;
char **Argv;
int Argc, First_Arg;
#if defined(USE_LD) || defined(CAN_DUMP) || defined(INIT_OBJECTS)
char *A_Out_Name;
char *Find_Executable();
#endif
#if defined(CAN_LOAD_OBJ) || defined(INIT_OBJECTS)
SYMTAB *The_Symbols;
#endif
void Exit_Handler () {
#if defined(CAN_LOAD_OBJ) || defined(INIT_OBJECTS)
Call_Finalizers ();
#endif
#ifdef USE_LD
Finit_Load ();
#endif
}
#ifndef ATEXIT
void exit (n) {
Exit_Handler ();
_cleanup ();
_exit (n);
}
#endif
#ifdef CAN_DUMP
int Was_Dumped;
#endif
/* To avoid that the stack copying code overwrites argv if a dumped
* copy of the interpreter is invoked with more arguments than the
* original a.out, move the stack base INITIAL_STK_OFFSET bytes down:
*/
main (ac, av) char **av; {
#ifdef CAN_DUMP
char unused[INITIAL_STK_OFFSET];
#endif
register char *initfile, *loadfile = 0, *loadpath = 0;
register debug = 0, heap = HEAP_SIZE;
Object file;
char foo;
if (ac == 0) {
av[0] = "Elk"; ac = 1;
}
Get_Stack_Limit ();
#if defined(USE_LD) || defined(CAN_DUMP) || defined(INIT_OBJECTS)
A_Out_Name = Find_Executable (av[0]);
#endif
Argc = ac; Argv = av;
First_Arg = 1;
#ifdef CAN_DUMP
if (Was_Dumped) {
Loader_Input[0] = '\0';
Install_Intr_Handler ();
(void)Funcall_Control_Point (Dump_Control_Point, Arg_True, 0);
/*NOTREACHED*/
}
#endif
for ( ; First_Arg < ac; First_Arg++) {
if (strcmp (av[First_Arg], "-g") == 0) {
debug = 1;
} else if (strcmp (av[First_Arg], "-i") == 0) {
Case_Insensitive = 1;
} else if (strcmp (av[First_Arg], "-v") == 0) {
Verbose = 1;
} else if (strcmp (av[First_Arg], "-h") == 0) {
if (++First_Arg == ac)
Usage ();
heap = atoi (av[First_Arg]);
} else if (strcmp (av[First_Arg], "-l") == 0) {
if (++First_Arg == ac || loadfile)
Usage ();
loadfile = av[First_Arg];
} else if (strcmp (av[First_Arg], "-p") == 0) {
if (++First_Arg == ac || loadpath)
Usage ();
loadpath = av[First_Arg];
} else if (strcmp (av[First_Arg], "--") == 0) {
First_Arg++;
break;
} else if (av[First_Arg][0] == '-') {
Usage ();
} else {
break;
}
}
stkbase = &foo;
ALIGN(stkbase);
Make_Heap (heap);
Init_Everything ();
#ifdef ATEXIT
if (atexit (Exit_Handler) != 0)
Fatal_Error ("atexit returned non-zero value");
#endif
#ifdef INIT_OBJECTS
if (Should_Init_Objects ()) {
Error_Tag = "init-objects";
The_Symbols = Open_File_And_Snarf_Symbols (A_Out_Name);
(void)Call_Initializers (The_Symbols, (char *)0);
}
#endif
if (loadpath)
Init_Loadpath (loadpath);
Error_Tag = "scheme-init";
initfile = INITFILE;
file = Make_String (initfile, strlen (initfile));
(void)General_Load (file, The_Environment);
Install_Intr_Handler ();
Error_Tag = "top-level";
if (loadfile == 0)
loadfile = "toplevel";
file = Make_String (loadfile, strlen (loadfile));
Interpreter_Initialized = 1;
GC_Debug = debug;
if (loadfile[0] == '-' && loadfile[1] == '\0')
Load_Source_Port (Standard_Input_Port);
else
(void)General_Load (file, The_Environment);
return 0;
}
static char *Usage_Msg[] = {
"Options:",
" [-l filename] Load file instead of standard toplevel",
" [-l -] Load from standard input",
" [-h heapsize] Heap size in KBytes",
" [-p loadpath] Initialize load-path (comma-list of directories)",
" [-g] Enable GC-debugging",
" [-i] Case-insensitive symbols",
" [-v] Verbose mode (print linker commands)",
" [--] End options and begin arguments",
0 };
Usage () {
char **p;
fprintf (stderr, "Usage: %s [options] [arguments]\n", Argv[0]);
for (p = Usage_Msg; *p; p++)
fprintf (stderr, "%s\n", *p);
exit (1);
}
Init_Everything () {
Init_String ();
Init_Symbol ();
Init_Env ();
Init_Error ();
Init_Exception ();
Init_Io ();
Init_Prim();
Init_Math ();
Init_Print ();
Init_Auto ();
Init_Heap ();
Init_Load ();
Init_Proc ();
Init_Special ();
Init_Read ();
Init_Features ();
Init_Terminate ();
#ifdef CAN_DUMP
Init_Dump ();
#endif
}
Get_Stack_Limit () {
#ifdef MAX_STACK_SIZE
Max_Stack = MAX_STACK_SIZE;
#else
struct rlimit rl;
if (getrlimit (RLIMIT_STACK, &rl) == -1) {
perror ("getrlimit");
exit (1);
}
Max_Stack = rl.rlim_cur;
#endif
Max_Stack -= STACK_MARGIN;
}
#if defined(USE_LD) || defined(CAN_DUMP) || defined(INIT_OBJECTS)
Executable (fn) char *fn; {
struct stat s;
return stat (fn, &s) != -1 && (s.st_mode & S_IFMT) == S_IFREG
&& access (fn, X_OK) != -1;
}
char *Find_Executable (fn) char *fn; {
char *path, *getenv();
static char buf[1025]; /* Can't use Path_Max or Safe_Malloc here */
register char *p;
for (p = fn; *p; p++) {
if (*p == '/') {
if (Executable (fn))
return fn;
else
Fatal_Error ("%s is not executable", fn);
}
}
if ((path = getenv ("PATH")) == 0)
path = ":/usr/ucb:/bin:/usr/bin";
do {
p = buf;
while (*path && *path != ':')
*p++ = *path++;
if (*path)
++path;
if (p > buf)
*p++ = '/';
strcpy (p, fn);
if (Executable (buf))
return buf;
} while (*path);
Fatal_Error ("cannot find pathname of %s", fn);
/*NOTREACHED*/
}
#endif
Object P_Command_Line_Args () {
Object ret, tail;
register i;
GC_Node2;
ret = tail = P_Make_List (Make_Fixnum (Argc-First_Arg), Null);
GC_Link2 (ret, tail);
for (i = First_Arg; i < Argc; i++, tail = Cdr (tail)) {
Object a = Make_String (Argv[i], strlen (Argv[i]));
Car (tail) = a;
}
GC_Unlink;
return ret;
}
Object P_Exit (argc, argv) Object *argv; {
exit (argc == 0 ? 0 : Get_Integer (argv[0]));
/*NOTREACHED*/
}
#ifdef INIT_OBJECTS
/* Returns true if DONT_INIT is not defined or if it is defined and
* argv[0] is not equal to DONT_INIT and doesn't end in a slash followed
* by DONT_INIT:
*/
Should_Init_Objects () {
#ifdef DONT_INIT
register char *dont = DONT_INIT;
register alen = strlen (A_Out_Name), dlen = strlen (dont);
return strcmp (A_Out_Name, dont) != 0 &&
!(alen > dlen && A_Out_Name[alen-dlen-1] == '/' &&
strcmp (A_Out_Name + alen - dlen, dont) == 0);
#else
return 1;
#endif
}
#endif /* INIT_OBJECTS */